Windows Game Programming for Dummies (2nd Edition)/WinGamProgFD.iso/pc/DirectX SDK/DXSDK/samples/Multimedia/VBSamples/DirectPlay/Chat/frmChat.frm

Visual Basic Form | 2001-10-08 | 10.7 KB | 249 lines

VERSION 5.00
Begin VB.Form frmChat
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "vbDirectPlay Chat"
   ClientHeight    =   5085
   ClientLeft      =   45
   ClientTop       =   330
   ClientWidth     =   7695
   Icon            =   "frmChat.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   5085
   ScaleWidth      =   7695
   StartUpPosition =   3  'Windows Default
   Begin VB.CommandButton cmdWhisper
      Caption         =   "Whisper"
      Height          =   255
      Left            =   5820
      TabIndex        =   3
      Top             =   4740
      Width           =   1695
   End
   Begin VB.TextBox txtSend
      Height          =   285
      Left            =   60
      TabIndex        =   0
      Top             =   4740
      Width           =   5595
   End
   Begin VB.ListBox lstUsers
      Height          =   4545
      Left            =   5760
      TabIndex        =   2
      Top             =   120
      Width           =   1815
   End
   Begin VB.TextBox txtChat
      Height          =   4635
      Left            =   60
      Locked          =   -1  'True
      MultiLine       =   -1  'True
      ScrollBars      =   3  'Both
      TabIndex        =   1
      TabStop         =   0   'False
      Top             =   60
      Width           =   5595
   End
Attribute VB_Name = "frmChat"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
'  Copyright (C) 1999-2001 Microsoft Corporation.  All Rights Reserved.
'  File:       frmChat.frm
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Implements DirectPlay8Event
Private Sub cmdWhisper_Click()
    Dim lMsg As Long, lOffset As Long
    Dim sChatMsg As String
    Dim oBuf() As Byte
    If lstUsers.ListIndex < 0 Then
        MsgBox "You must select a user in the list before you can whisper to that person.", vbOKOnly Or vbInformation, "Select someone"
        Exit Sub
    End If
    If lstUsers.ItemData(lstUsers.ListIndex) = 0 Then
        MsgBox "Why are you whispering to yourself?", vbOKOnly Or vbInformation, "Select someone else"
        Exit Sub
    End If
    If txtSend.Text = vbNullString Then
        MsgBox "What's the point of whispering if you have nothing to say..", vbOKOnly Or vbInformation, "Enter text"
        Exit Sub
    End If

    'Send this message to the person you are whispering to
    lMsg = MsgWhisper
    lOffset = NewBuffer(oBuf)
    AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
    sChatMsg = txtSend.Text
    AddStringToBuffer oBuf, sChatMsg, lOffset
    txtSend.Text = vbNullString
    dpp.SendTo lstUsers.ItemData(lstUsers.ListIndex), oBuf, 0, DPNSEND_NOLOOPBACK
    UpdateChat "**<" & gsUserName & ">** " & sChatMsg
End Sub
Private Sub Form_Load()
    'Oh good, we want to play a multiplayer game.
    'First lets get the dplay connection started
    'Here we will init our DPlay objects
    InitDPlay
    'Now we can create a new Connection Form (which will also be our message pump)
    Set DPlayEventsForm = New DPlayConnect
    'Start the connection form (it will either create or join a session)
    If Not DPlayEventsForm.StartConnectWizard(dx, dpp, AppGuid, 20, Me) Then
        Cleanup
        End
    Else 'We did choose to play a game
        gsUserName = DPlayEventsForm.UserName
        If DPlayEventsForm.IsHost Then
            Me.Caption = Me.Caption & " (HOST)"
        End If
    End If
End Sub
Private Sub Form_Unload(Cancel As Integer)
    Me.Hide
    DPlayEventsForm.DoSleep 50
    Cleanup
End Sub
Private Sub UpdateChat(ByVal sString As String)
    'Update the chat window first
    txtChat.Text = txtChat.Text & sString & vbCrLf
    'Now limit the text in the window to be 16k
    If Len(txtChat.Text) > 16384 Then
        txtChat.Text = Right$(txtChat.Text, 16384)
    End If
    'Autoscroll the text
    txtChat.SelStart = Len(txtChat.Text)
End Sub
Private Sub txtSend_KeyPress(KeyAscii As Integer)
    Dim lMsg As Long, lOffset As Long
    Dim sChatMsg As String
    Dim oBuf() As Byte
    If KeyAscii = vbKeyReturn Then
        If txtSend.Text <> vbNullString Then 'Make sure they are trying to send something
            'Send this message to everyone
            lMsg = MsgChat
            lOffset = NewBuffer(oBuf)
            AddDataToBuffer oBuf, lMsg, LenB(lMsg), lOffset
            sChatMsg = txtSend.Text
            AddStringToBuffer oBuf, sChatMsg, lOffset
            txtSend.Text = vbNullString
            KeyAscii = 0
            dpp.SendTo DPNID_ALL_PLAYERS_GROUP, oBuf, 0, DPNSEND_NOLOOPBACK
            UpdateChat "<" & gsUserName & ">" & sChatMsg
        End If 'We won't set KeyAscii to 0 here, because if they are trying to
               'send blank data, we don't care about the ding for hitting enter on
               'an empty line
    End If
End Sub
Private Function GetName(ByVal lID As Long) As String
    Dim lCount As Long
    GetName = vbNullString
    For lCount = 0 To lstUsers.ListCount - 1
        If lstUsers.ItemData(lCount) = lID Then 'This is the player
            GetName = lstUsers.List(lCount)
            Exit For
        End If
    Next
End Function
Private Sub DirectPlay8Event_AddRemovePlayerGroup(ByVal lMsgID As Long, ByVal lPlayerID As Long, ByVal lGroupID As Long, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AppDesc(fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_AsyncOpComplete(dpnotify As DxVBLibA.DPNMSG_ASYNC_OP_COMPLETE, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_ConnectComplete(dpnotify As DxVBLibA.DPNMSG_CONNECT_COMPLETE, fRejectMsg As Boolean)
    If dpnotify.hResultCode <> 0 Then
        'For some reason we could not connect.  All available slots must be closed.
        MsgBox "Connect Failed.  Error: 0x" & CStr(Hex$(dpnotify.hResultCode)) & "  - This sample will now close.", vbOKOnly Or vbCritical, "Closing"
        DPlayEventsForm.CloseForm Me
    End If
End Sub
Private Sub DirectPlay8Event_CreateGroup(ByVal lGroupID As Long, ByVal lOwnerID As Long, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_CreatePlayer(ByVal lPlayerID As Long, fRejectMsg As Boolean)
    Dim dpPeer As DPN_PLAYER_INFO
    dpPeer = dpp.GetPeerInfo(lPlayerID)

    'Add this person to chat (even if it's me)
    lstUsers.AddItem dpPeer.Name
    If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) <> DPNPLAYER_LOCAL Then 'this isn't me, someone just joined
        UpdateChat "- " & dpPeer.Name & " is chatting"
        'If it's not me, include an ItemData
        lstUsers.ItemData(lstUsers.ListCount - 1) = lPlayerID
    End If
End Sub
Private Sub DirectPlay8Event_DestroyGroup(ByVal lGroupID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_DestroyPlayer(ByVal lPlayerID As Long, ByVal lReason As Long, fRejectMsg As Boolean)
    Dim lCount As Long
    'We only care when someone leaves.  When they join we will receive a 'MSGJoin'
    'Remove this player from our list
    For lCount = 0 To lstUsers.ListCount - 1
        If lstUsers.ItemData(lCount) = lPlayerID Then 'This is the player
            UpdateChat "-- " & lstUsers.List(lCount) & " is no longer chatting."
            lstUsers.RemoveItem lCount
            Exit For
        End If
    Next
End Sub
Private Sub DirectPlay8Event_EnumHostsQuery(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_QUERY, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_EnumHostsResponse(dpnotify As DxVBLibA.DPNMSG_ENUM_HOSTS_RESPONSE, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_HostMigrate(ByVal lNewHostID As Long, fRejectMsg As Boolean)
    Dim dpPeer As DPN_PLAYER_INFO
    dpPeer = dpp.GetPeerInfo(lNewHostID)
    If (dpPeer.lPlayerFlags And DPNPLAYER_LOCAL) = DPNPLAYER_LOCAL Then 'I am the new host
        Me.Caption = Me.Caption & " (HOST)"
    End If
End Sub
Private Sub DirectPlay8Event_IndicateConnect(dpnotify As DxVBLibA.DPNMSG_INDICATE_CONNECT, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_IndicatedConnectAborted(fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_InfoNotify(ByVal lMsgID As Long, ByVal lNotifyID As Long, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_Receive(dpnotify As DxVBLibA.DPNMSG_RECEIVE, fRejectMsg As Boolean)
    'process what msgs we receive.
    Dim lMsg As Long, lOffset As Long
    Dim dpPeer As DPN_PLAYER_INFO, sName As String
    Dim sChat As String
    With dpnotify
    GetDataFromBuffer .ReceivedData, lMsg, LenB(lMsg), lOffset
    Select Case lMsg
    Case MsgChat
        sName = GetName(.idSender)
        sChat = GetStringFromBuffer(.ReceivedData, lOffset)
        UpdateChat "<" & sName & "> " & sChat
    Case MsgWhisper
        sName = GetName(.idSender)
        sChat = GetStringFromBuffer(.ReceivedData, lOffset)
        UpdateChat "**<" & sName & ">** " & sChat
    End Select
    End With
End Sub
Private Sub DirectPlay8Event_SendComplete(dpnotify As DxVBLibA.DPNMSG_SEND_COMPLETE, fRejectMsg As Boolean)
    'VB requires that we must implement *every* member of this interface
End Sub
Private Sub DirectPlay8Event_TerminateSession(dpnotify As DxVBLibA.DPNMSG_TERMINATE_SESSION, fRejectMsg As Boolean)
    If dpnotify.hResultCode = DPNERR_HOSTTERMINATEDSESSION Then
        MsgBox "The host has terminated this session.  This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
    Else
        MsgBox "This session has been lost.  This sample will now exit.", vbOKOnly Or vbInformation, "Exiting"
    End If
    DPlayEventsForm.CloseForm Me
End Sub